home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / timezone.scm < prev    next >
Text File  |  1999-04-19  |  10KB  |  265 lines
  1. ;;;; "timezone.scm" Compute timezones and DST from TZ environment variable.
  2. ;;; Copyright (C) 1994, 1996, 1997 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;; The C-library support for time in general and time-zones in particular
  21. ;; stands as a fine example of how *not* to create interfaces.
  22. ;; 
  23. ;; Functions are not consistently named.  Support for GMT is offered in one
  24. ;; direction only; The localtime function returns some timezone data in the
  25. ;; structure which it returns, and some data in shared global variables.
  26. ;; The structure which localtime returns is overwritten with each
  27. ;; invocation.  There is no way to find local time in zones other than GMT
  28. ;; and the local timezone.
  29. ;; 
  30. ;; The tzfile(5) format encodes only a single timezone per file.  There is
  31. ;; no dispatch on zone names, so multiple copies of a timezone file exist
  32. ;; under different names.  The TZ `:' specification is unix filesystem
  33. ;; specific.  The tzfile(5) format makes no provision for byte-order
  34. ;; differences; It mixes 32-bit integer data with characters; specifying
  35. ;; ASCII bytes, it is incompatible with different character sizes.  The
  36. ;; binary format makes it impossible to easily inspect a file for
  37. ;; corruption.
  38. ;; 
  39. ;; I have corrected most of the failings of the C-library time interface in
  40. ;; SLIB while maintaining compatablility.  I wrote support for Linux
  41. ;; timezone files because on a system where TZ is not set, there is no
  42. ;; other way to reveal this information.  HP-UX appears to have a more
  43. ;; sensible arrangement; I invite you to add support for it and other
  44. ;; platforms.
  45. ;; 
  46. ;; Writing this was a long, tedious, and unenlightening process.  I hope it
  47. ;; is useful.
  48. ;;
  49. ;; Sat Nov 15 00:15:33 1997  Aubrey Jaffer  <jaffer@martigny.ai.mit.edu>
  50.  
  51. (provide 'time-zone)
  52. (require 'scanf)
  53.  
  54. (define daylight? #f)
  55. (define *timezone* 0)
  56. (define tzname '#("UTC" "???"))
  57.  
  58. (define tz:default #f)
  59.  
  60. ;;; This definition is here so that READ-TZFILE can verify the
  61. ;;; existence of these files before loading tzfile.scm to actually
  62. ;;; read them.
  63. (define tzfile:vicinity (make-vicinity 
  64.              (if (file-exists? "/usr/share/zoneinfo/.")
  65.                  "/usr/share/zoneinfo/"
  66.                  "/usr/lib/zoneinfo/")))
  67.  
  68. (define (read-tzfile path)
  69.   (let ((realpath
  70.      (cond ((not path) (in-vicinity tzfile:vicinity "localtime"))
  71.            ((or (char-alphabetic? (string-ref path 0))
  72.             (char-numeric? (string-ref path 0)))
  73.         (in-vicinity tzfile:vicinity path))
  74.            (else path))))
  75.     (and (file-exists? realpath)
  76.      (let ((zone #f))
  77.        (require 'tzfile)
  78.        (set! zone (tzfile:read realpath))
  79.        (if zone (list->vector (cons 'tz:file zone))
  80.            (slib:error 'read-tzfile realpath))))))
  81.  
  82. ;;; Parse Posix TZ string.
  83.  
  84. (define (string->transition-day-time str)
  85.   (let ((month 0) (week 0) (day #f) (junk #f))
  86.     (or (case (sscanf str "J%u%s" day junk)
  87.       ((1) (and (<= 1 day 365)
  88.             (list #f #f day)))
  89.       (else #f))
  90.     (case (sscanf str "%u%s" day junk)
  91.       ((1) (and (<= 0 day 365)
  92.             (list #f #t day)))
  93.       (else #f))
  94.     (case (sscanf str "M%u.%u.%u%s" month week day junk)
  95.       ((3) (and (<= 1 month 12)
  96.             (<= 1 week 5)
  97.             (<= 0 day 6)
  98.             (list month week day)))
  99.       (else #f)))))
  100.  
  101. (define (string->transition-time str)
  102.   (let ((date #f) (time "2") (junk #f))
  103.     (and (or (eqv? 2 (sscanf str "%[JM.0-9]/%[:0-9]%s" date time junk))
  104.          (eqv? 1 (sscanf str "%[JM.0-9]" date junk)))
  105.      (let ((day (string->transition-day-time date))
  106.            (tim (string->time-offset time)))
  107.        (and day tim (append day (list tim)))))))
  108.  
  109. (define (string->time-offset str)
  110.   (and str (string? str) (positive? (string-length str))
  111.        (let ((hh #f) (mm 0) (ss 0) (junk #f))
  112.      (and (<= 1 (sscanf (if (memv (string-ref str 0) '(#\+ #\-))
  113.                 (substring str 1 (string-length str))
  114.                 str)
  115.                 "%u:%u:%u%s" hh mm ss junk)
  116.           3)
  117.           hh (<= 0 hh 23) (<= 0 mm 59) (<= 0 ss 59)
  118.           (* (if (char=? #\- (string-ref str 0)) -1 1)
  119.          (+ ss (* 60 (+ mm (* hh 60)))))))))
  120.  
  121. (define (string->time-zone tz)
  122.   (let ((tzname #f) (offset #f) (dtzname #f) (doffset #f)
  123.             (start-str #f) (end-str #f) (junk #f))
  124.     (define found
  125.       (sscanf
  126.        tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-]%[-:+0-9],%[JM.0-9/:],%[JM.0-9/:]%s"
  127.        tzname offset dtzname doffset start-str end-str junk))
  128.     (set! offset (string->time-offset offset))
  129.     (set! doffset (string->time-offset doffset))
  130.     (cond
  131.      ((and offset (eqv? 3 found))
  132.       (set! doffset (+ -3600 offset))
  133.       (set! found
  134.         (+ 1
  135.            (sscanf
  136.         tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-],%[JM.0-9/:],%[JM.0-9/:]%s"
  137.         tzname offset dtzname start-str end-str junk)))
  138.       (set! offset (string->time-offset offset))))
  139.     (case found
  140.       ((2) (vector 'tz:fixed tz tzname offset))
  141.       ((4) (vector 'tz:rule tz tzname dtzname offset doffset
  142.            (list 4 1 0 7200) (list 10 5 0 7200)))
  143.       ((6) (let ((start (string->transition-time start-str))
  144.          (end   (string->transition-time   end-str)))
  145.          (and
  146.           start end
  147.           (vector 'tz:rule tz tzname dtzname offset doffset start end))))
  148.       (else #f))))
  149.  
  150. (define (time-zone tz)
  151.   (cond ((not tz) (read-tzfile #f))
  152.     ((vector? tz) tz)
  153.     ((eqv? #\: (string-ref tz 0))
  154.      (read-tzfile (substring tz 1 (string-length tz))))
  155.     (else (string->time-zone tz))))
  156.  
  157. ;;; Use the timezone
  158.  
  159. (define (tzrule->caltime year previous-gmt-offset
  160.              tr-month tr-week tr-day tr-time)
  161.   (define leap? (leap-year? year))
  162.   (define gmmt
  163.     (time:invert time:gmtime
  164.          (vector 0 0 0 1 (if tr-month (+ -1 tr-month) 0) year #f #f 0)))
  165.   (offset-time
  166.    gmmt
  167.    (+ tr-time previous-gmt-offset
  168.       (* 3600 24
  169.      (if tr-month
  170.          (let* ((fdow (vector-ref (time:gmtime gmmt) 6)))
  171.            (case tr-week
  172.          ((1 2 3 4) (+ (modulo (- tr-day fdow) 7)
  173.                    (* 7 (+ -1 tr-week))))
  174.          ((5)
  175.           (do ((mmax (vector-ref
  176.                   (vector-ref time:days/month (if leap? 1 0))
  177.                   (+ -1 tr-month)))
  178.                (d (modulo (- tr-day fdow) 7) (+ 7 d)))
  179.               ((>= d mmax) (+ -7 d))))
  180.          (else (slib:error 'tzrule->caltime
  181.                    "week out of range" tr-week))))
  182.          (+ tr-day
  183.         (if (and (not tr-week) (>= tr-day 60) (leap-year? year))
  184.             1 0)))))))
  185.  
  186. (define (tz:params caltime tz)
  187.   (case (vector-ref tz 0)
  188.     ((tz:fixed) (list 0 (vector-ref tz 3) (vector-ref tz 2)))
  189.     ((tz:rule)
  190.      (let* ((year (vector-ref (time:gmtime caltime) 5))
  191.         (ttime0 (apply tzrule->caltime
  192.                year (vector-ref tz 4) (vector-ref tz 6)))
  193.         (ttime1 (apply tzrule->caltime
  194.                year (vector-ref tz 5) (vector-ref tz 7)))
  195.         (dst (if (and (not (negative? (difftime caltime ttime0)))
  196.               (negative? (difftime caltime ttime1)))
  197.              1 0)))
  198.        (list dst (vector-ref tz (+ 4 dst)) (vector-ref tz (+ 2 dst)))
  199.        ;;(for-each display (list (gtime ttime0) (gtime caltime) (gtime ttime1)))
  200.        ))
  201.     ((tz:file) (let ((zone-spec (tzfile:get-zone-spec caltime tz)))
  202.          (list (if (vector-ref zone-spec 2) 1 0)
  203.                (- (vector-ref zone-spec 1))
  204.                (vector-ref zone-spec 0))))
  205.     (else (slib:error 'tz:params "unknown timezone type" tz))))
  206.  
  207. (define (tz:std-offset zone)
  208.   (case (vector-ref zone 0)
  209.     ((tz:fixed) (vector-ref zone 3))
  210.     ((tz:rule) (vector-ref zone 4))
  211.     ((tz:file)
  212.      (let ((mode-table (vector-ref zone 2)))
  213.        (do ((type-idx 0 (+ 1 type-idx)))
  214.        ((or (>= type-idx (vector-length mode-table))
  215.         (not (vector-ref (vector-ref mode-table type-idx) 2)))
  216.         (if (>= type-idx (vector-length mode-table))
  217.         (vector-ref (vector-ref mode-table 0) 1)
  218.         (- (vector-ref (vector-ref mode-table type-idx) 1)))))))
  219.     (else (slib:error 'tz:std-offset "unknown timezone type" tz))))
  220.  
  221. ;;; Interpret the TZ envariable.
  222. (define (tzset . opt-tz)
  223.   (define tz (if (null? opt-tz)
  224.          (getenv "TZ")
  225.          (car opt-tz)))
  226.   (if (or (not tz:default)
  227.       (and (string? tz) (not (string-ci=? tz (vector-ref tz:default 1)))))
  228.       (set! tz:default (or (time-zone tz) '#(tz:fixed "UTC" "GMT" 0))))
  229.   (case (vector-ref tz:default 0)
  230.     ((tz:fixed)
  231.      (set! tzname (vector (vector-ref tz:default 2) "???"))
  232.      (set! daylight? #f)
  233.      (set! *timezone* (vector-ref tz:default 3)))
  234.     ((tz:rule)
  235.      (set! tzname (vector (vector-ref tz:default 2)
  236.               (vector-ref tz:default 3)))
  237.      (set! daylight? #t)
  238.      (set! *timezone* (vector-ref tz:default 4)))
  239.     ((tz:file)
  240.      (let ((mode-table (vector-ref tz:default 2))
  241.        (transition-types (vector-ref tz:default 5)))
  242.        (set! daylight? #f)
  243.        (set! *timezone* (vector-ref (vector-ref mode-table 0) 1))
  244.        (set! tzname (make-vector 2 #f))
  245.        (do ((type-idx 0 (+ 1 type-idx)))
  246.        ((>= type-idx (vector-length mode-table)))
  247.      (let ((rec (vector-ref mode-table type-idx)))
  248.        (if (vector-ref rec 2)
  249.            (set! daylight? #t)
  250.            (set! *timezone* (- (vector-ref rec 1))))))
  251.  
  252.        (do ((transition-idx (+ -1 (vector-length transition-types))
  253.                 (+ -1 transition-idx)))
  254.        ((or (negative? transition-idx)
  255.         (and (vector-ref tzname 0) (vector-ref tzname 1))))
  256.      (let ((rec (vector-ref mode-table
  257.                 (vector-ref transition-types transition-idx))))
  258.        (if (vector-ref rec 2)
  259.            (if (not (vector-ref tzname 1))
  260.            (vector-set! tzname 1 (vector-ref rec 0)))
  261.            (if (not (vector-ref tzname 0))
  262.            (vector-set! tzname 0 (vector-ref rec 0))))))))
  263.     (else (slib:error 'tzset "unknown timezone type" tz)))
  264.   tz:default)
  265.